home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 551-575 / disk_556 / scheme2c / scheme-src.lzh / scrt / callcc.c < prev    next >
C/C++ Source or Header  |  1991-10-11  |  7KB  |  193 lines
  1. /* SCHEME->C */
  2.  
  3. /*              Copyright 1989 Digital Equipment Corporation
  4.  *                         All Rights Reserved
  5.  *
  6.  * Permission to use, copy, and modify this software and its documentation is
  7.  * hereby granted only under the following terms and conditions.  Both the
  8.  * above copyright notice and this permission notice must appear in all copies
  9.  * of the software, derivative works or modified versions, and any portions
  10.  * thereof, and both notices must appear in supporting documentation.
  11.  *
  12.  * Users of this software agree to the terms and conditions set forth herein,
  13.  * and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  14.  * right and license under any changes, enhancements or extensions made to the
  15.  * core functions of the software, including but not limited to those affording
  16.  * compatibility with other hardware or software environments, but excluding
  17.  * applications which incorporate this software.  Users further agree to use
  18.  * their best efforts to return to Digital any such changes, enhancements or
  19.  * extensions that they make and inform Digital of noteworthy uses of this
  20.  * software.  Correspondence should be provided to Digital at:
  21.  * 
  22.  *                       Director of Licensing
  23.  *                       Western Research Laboratory
  24.  *                       Digital Equipment Corporation
  25.  *                       100 Hamilton Avenue
  26.  *                       Palo Alto, California  94301  
  27.  * 
  28.  * This software may be distributed (but not offered for sale or transferred
  29.  * for compensation) to third parties, provided such third parties agree to
  30.  * abide by the terms and conditions of this notice.  
  31.  * 
  32.  * THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  33.  * WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  34.  * MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  35.  * CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  36.  * DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  37.  * PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  38.  * ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  39.  * SOFTWARE.
  40. */
  41.  
  42. /* The following procedures implement CALL-WITH-CURRENT-CONTINUATION.
  43.    CALLCCCONTINUING is the function that is executed when a continuation is
  44.    applied.  It is called with the result to be returned and the procedure's
  45.    closure which is the continuation created by the initial call to
  46.    TSC_CALLWITHCURRENTCONTINUATION.  It will unwind the stack until the right
  47.    return point is found.  If it is not found, then it will restore the stack
  48.    from the continuation(s).  Once the stack is known to have the right
  49.    contents, it will restore the correct state with longjmp.
  50. */
  51.  
  52. /* External declarations */
  53.  
  54. #include "objects.h"
  55. #include "scinit.h"
  56. #include "heap.h"
  57. #include "callcc.h"
  58. #include "apply.h"
  59. #include "signal.h"
  60.  
  61. #ifdef SPARC
  62. extern    sc_setjmp();
  63. /* This is really tacky, but it appears to be necessary because of the */
  64. /* compiler on the DECStation 5100.  That beast does not seem to be able to */
  65. /* grok the #pragma directive. The one I tried appeared to be */
  66. /* Ultrix T3.1D-0 (Rev. 45) Worksystem X2.2.  */
  67. #include "sparc-pragma.h"
  68. #define setjmp( x )    sc_setjmp( x )
  69. #define longjmp( x, y )    sc_longjmp( x, y )
  70. #endif
  71.  
  72. #ifdef MIPS
  73. extern  sc_setsp();
  74. #endif
  75.  
  76. #ifdef VAX
  77. #define  longjmp( x, y )    sc_longjmp( x, y )
  78. #define  setjmp( x )        sc_setjmp( x )
  79. #endif
  80.  
  81. #ifdef APOLLO
  82. extern sc_setregs(int a6, int a7);
  83. #endif
  84.  
  85. #ifdef PRISM
  86. #define longjmp(x, y)        sc_longjmp(x, y)
  87. #define setjmp(x)        sc_setjmp(x)
  88. #endif
  89.  
  90. TSCP  sc_clink;        /* Pointer to inner most continuation on stack. */
  91.  
  92. /* Static declarations for data structures internal to the module.  These
  93.    variables may be static as they are only used under MUTEX. */
  94.  
  95. static TSCP  callccresult,    /* Passes result across longjmp. */
  96.                callcccp;        /* Preserves cp during stack rebuilding. */
  97.  
  98. static int  *fp,        /* Temps for constructing continuation */
  99.             *tp,
  100.             *tos,
  101.             rcount,
  102.             count;
  103.  
  104. static  callcccontinuing( result, cp )
  105.     TSCP  result, cp;
  106. {
  107.     MUTEXON;
  108.     callccresult = result;
  109.     callcccp = cp;
  110.     /* Unwind CLINK to see if this continuation is currently on the
  111.        stack.  */
  112.     while (sc_clink != EMPTYLIST)  {
  113.        if  (sc_clink == cp)
  114.           longjmp( (T_U(cp))->continuation.savedstate, 1 );
  115.        sc_clink = (T_U(sc_clink))->continuation.continuation;
  116.     }
  117.     /* Continuation is not currently on the stack, so transfer to it and
  118.            it will restore the stack.  */
  119. #ifdef MIPS
  120.     sc_setsp( (T_U(callcccp))->continuation.address );
  121. #endif
  122. #ifdef APOLLO
  123.     sc_setregs( (T_U(callcccp))->continuation.savedstate[3],
  124.            (T_U(callcccp))->continuation.savedstate[2]);
  125. #endif
  126.     longjmp( (T_U(callcccp))->continuation.savedstate, 1 );
  127. }
  128.  
  129. TSCP  sc_ntinuation_1af38b9f_v;
  130.  
  131. TSCP  sc_ntinuation_1af38b9f( function )
  132.     TSCP  function;
  133. {
  134.     SCP  cp;        /* Pointer to the continuation */
  135.     int  *save_fp,        /* Save static values across heap allocate */
  136.          save_count;
  137.  
  138.     MUTEXON;
  139.     if (sc_clink == EMPTYLIST)
  140.        fp = sc_stackbase;
  141.     else
  142.        fp = (T_U(sc_clink))->continuation.address;
  143.     count = ((unsigned)(fp)-(unsigned)(STACKPTR))/4;
  144.     save_fp = fp;
  145.     save_count = count;
  146.     cp = sc_allocateheap( NULLCONTINUATIONSIZE+count+2+sc_maxdisplay,
  147.                   CONTINUATIONTAG,
  148.                       NULLCONTINUATIONSIZE+count+sc_maxdisplay );
  149.     fp = save_fp;
  150.     count = save_count;
  151.     tos = STACKPTR;    
  152.     cp->continuation.continuation = sc_clink;
  153.     cp->continuation.stacktrace = sc_stacktrace;
  154.     sc_clink = U_TX( cp );
  155.     cp->continuation.address = tos;
  156.     tp = &cp->continuation.word0;
  157.     rcount = sc_maxdisplay;
  158.     while  (rcount--)  *tp++ = (int)sc_display[ rcount ];
  159.     while  (count--)  *tp++ = *tos++;
  160.     MUTEXOFF;
  161.     if  (setjmp( cp->continuation.savedstate ) == 0)  {
  162.        callccresult = sc_apply_2dtwo( function,
  163.                        sc_cons( sc_makeprocedure( 1, 0,
  164.                                   callcccontinuing,
  165.                                       U_TX( cp ) ),
  166.                          EMPTYLIST ) );
  167.        sc_clink = T_U( sc_clink )->continuation.continuation;
  168.        return( callccresult );
  169.     }
  170.     /* Return here when the continuation is invoked. */
  171.     if  (sc_clink == EMPTYLIST)  {
  172.        sc_clink = callcccp;
  173.        while  (sc_clink != EMPTYLIST)  {
  174.           tp = (T_U(sc_clink))->continuation.address;
  175.           fp = &(T_U(sc_clink))->continuation.word0+sc_maxdisplay;
  176.           count = (T_U(sc_clink))->continuation.length-sc_maxdisplay-
  177.                           NULLCONTINUATIONSIZE;
  178.           while  (count--)  *tp++ = *fp++;
  179.           sc_clink = (T_U(sc_clink))->continuation.continuation;
  180.        }
  181.     }
  182.     tp = &T_U( callcccp )->continuation.word0;
  183.     rcount = sc_maxdisplay;
  184.     while  (rcount--)  sc_display[ rcount ] = (TSCP)(*tp++);
  185.     sc_clink = T_U( callcccp )->continuation.continuation;
  186.     sc_stacktrace = T_U( callcccp )->continuation.stacktrace;
  187.     /* Move result onto the stack under mutex */
  188.     function = callccresult;
  189.     MUTEXOFF;
  190.     return( function );
  191. }
  192.  
  193.